home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / structure.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  10.9 KB  |  446 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     structure.c
  24.  
  25.     structure interface
  26. */
  27.  
  28. #include "include.h"
  29.  
  30.  
  31. #define COERCE_DEF(x) if (type_of(x)==t_symbol) \
  32.   x=getf(x->s.s_plist,siLs_data,Cnil)
  33.  
  34. #define check_type_structure(x) \
  35.   if(type_of((x))!=t_structure) \
  36.     FEwrong_type_argument(Sstructure,(x)) 
  37.  
  38.  
  39. bool
  40. structure_subtypep(x, y)
  41. object x, y;
  42. { if (x==y) return 1;
  43.   if (type_of(x)!= t_structure
  44.       || type_of(y)!=t_structure)
  45.     FEerror("bad call to structure_subtypep",0);
  46.   {if (S_DATA(y)->included == Cnil) return 0;
  47.    while ((x=S_DATA(x)->includes) != Cnil)
  48.      { if (x==y) return 1;}
  49.    return 0;
  50.  }}
  51.  
  52. static
  53. bad_raw_type()
  54. {           FEerror("Bad raw struct type",0);}
  55.  
  56.  
  57. object
  58. structure_ref(x, name, i)
  59. object x, name;
  60. int i;
  61. {unsigned short *s_pos;
  62.  COERCE_DEF(name);
  63.  if (type_of(x) != t_structure ||
  64.      (type_of(name)!=t_structure) ||
  65.      !structure_subtypep(x->str.str_def, name))
  66.    FEwrong_type_argument((type_of(name)==t_structure ?
  67.               S_DATA(name)->name : name),
  68.              x);
  69.  s_pos = &SLOT_POS(x->str.str_def,0);
  70.  switch((SLOT_TYPE(x->str.str_def,i)))
  71.    {
  72.    case aet_object: return(STREF(object,x,s_pos[i]));
  73.    case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
  74.    case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
  75.    case aet_bit:
  76.    case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
  77.    case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
  78.    case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
  79.    case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
  80.    case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
  81.    case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
  82.    default:
  83.      bad_raw_type();
  84.      return 0;
  85.    }}
  86.  
  87.  
  88. void
  89. siLstructure_ref1()
  90. {object x=vs_base[0];
  91.  int n=fix(vs_base[1]);
  92.  object def;
  93.  check_type_structure(x);
  94.  def=x->str.str_def;
  95.  if(n>= S_DATA(def)->length)
  96.    FEerror("Structure ref out of bounds",0);
  97.  vs_base[0]=structure_ref(x,x->str.str_def,n);
  98.  vs_top=vs_base+1;
  99. }
  100.  
  101.  
  102.  
  103.  
  104.  
  105. object
  106. structure_set(x, name, i, v)
  107. object x, name, v;
  108. int i;
  109. {unsigned short *s_pos;
  110.  
  111.  COERCE_DEF(name);
  112.  if (type_of(x) != t_structure ||
  113.      type_of(name) != t_structure ||
  114.      !structure_subtypep(x->str.str_def, name))
  115.    FEwrong_type_argument((type_of(name)==t_structure ?
  116.               S_DATA(name)->name : name)
  117.              , x);
  118.  
  119. #ifdef SGC
  120.  /* make sure the structure header is on a writable page */
  121.  if (x->d.m) FEerror("bad gc field"); else  x->d.m = 0;
  122. #endif   
  123.  
  124.  s_pos= & SLOT_POS(x->str.str_def,0);
  125.  switch(SLOT_TYPE(x->str.str_def,i)){
  126.    
  127.    case aet_object: STREF(object,x,s_pos[i])=v; break;
  128.    case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  129.    case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  130.    case aet_bit:
  131.    case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  132.    case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  133.    case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  134.    case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  135.    case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  136.    case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  137.  default:
  138.    bad_raw_type();
  139.  
  140.    }
  141.  return(v);
  142. }
  143.  
  144. void
  145. siLstructure_subtype_p()
  146. {object x,y;
  147.  check_arg(2);
  148.  x=vs_base[0];
  149.  y=vs_base[1];
  150.  if (type_of(x)!=t_structure)
  151.    {vs_base[0]=Cnil; goto BOTTOM;}
  152.  x=x->str.str_def;
  153.  COERCE_DEF(y);
  154.  if (structure_subtypep(x,y)) vs_base[0]=Ct;
  155.  else vs_base[0]=Cnil;
  156.  BOTTOM:
  157.  vs_top=vs_base+1;
  158. }
  159.  
  160.      
  161.  
  162. object
  163. structure_to_list(x)
  164. object x;
  165. {
  166.     object *p, s;
  167.     struct s_data *def=S_DATA(x->str.str_def);
  168.     int i, n;
  169.     
  170.     s = def->slot_descriptions;
  171.     vs_push(def->name);
  172.     vs_push(Cnil);
  173.     p = &vs_head;
  174.     for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
  175.         *p = make_cons(car(s->c.c_car), Cnil);
  176.         p = &((*p)->c.c_cdr);
  177.         *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
  178.         p = &((*p)->c.c_cdr);
  179.     }
  180.     stack_cons();
  181.     return(vs_pop);
  182. }
  183.  
  184. void
  185. siLmake_structure()
  186. {
  187.   object x,name,*base;
  188.   struct s_data *def;
  189.   int narg, i,size;
  190.   base=vs_base;
  191.   if ((narg = vs_top - base) == 0)
  192.     too_few_arguments();
  193.   x = alloc_object(t_structure);
  194.   name=base[0];
  195.   COERCE_DEF(name);
  196.   if (type_of(name)!=t_structure  ||
  197.       (def=S_DATA(name))->length != --narg)
  198.     FEerror("Bad make_structure args for type ~a",1,
  199.         base[0]);
  200.   x->str.str_def = name;
  201.   x->str.str_self = NULL;
  202.   size=S_DATA(name)->size;
  203.   base[0] = x;
  204.   x->str.str_self = (object *)
  205.     (def->staticp == Cnil ? alloc_relblock(size)
  206.      : alloc_contblock(size));
  207.   /* There may be holes in the structure.
  208.      We want them zero, so that equal can work better.
  209.      */
  210.   if (S_DATA(name)->has_holes != Cnil)
  211.     bzero(x->str.str_self,size);
  212.   {unsigned char *s_type;
  213.    unsigned short *s_pos;
  214.    s_pos= (&SLOT_POS(x->str.str_def,0));
  215.    s_type = (&(SLOT_TYPE(x->str.str_def,0)));
  216.    base=base+1;
  217.    for (i = 0;  i < narg;  i++)
  218.      {object v=base[i];
  219.       switch(s_type[i]){
  220.          
  221.       case aet_object: STREF(object,x,s_pos[i])=v; break;
  222.       case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
  223.       case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
  224.       case aet_bit:
  225.       case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
  226.       case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
  227.       case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
  228.       case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
  229.       case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
  230.       case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
  231.       default:
  232.     bad_raw_type();
  233.  
  234.       }}
  235.    vs_top = base;
  236.    vs_base=base-1;
  237.  
  238.  }
  239. }
  240.  
  241. void
  242. siLcopy_structure()
  243. {
  244.     object x, y;
  245.     struct s_data *def;
  246.  
  247.     if (vs_top-vs_base < 1) too_few_arguments();
  248.     x = vs_base[0];
  249.     check_type_structure(x);
  250.     vs_base[0] = y = alloc_object(t_structure);
  251.     def=S_DATA(y->str.str_def = x->str.str_def);
  252.     y->str.str_self = NULL;
  253.     y->str.str_self = (object *)alloc_relblock(def->size);
  254.     bcopy(x->str.str_self,y->str.str_self,def->size);
  255.     vs_top=vs_base+1;
  256. }
  257.  
  258. void
  259. siLstructure_name()
  260. {
  261.     check_arg(1);
  262.     check_type_structure(vs_base[0]);
  263.     vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
  264. }
  265.  
  266. void
  267. siLstructure_ref()
  268. {
  269.     check_arg(3);
  270.     vs_base[0]=structure_ref(vs_base[0],vs_base[1],fix(vs_base[2]));
  271.     vs_top=vs_base+1;
  272. }
  273.  
  274. void
  275. siLstructure_set()
  276. {
  277.     check_arg(4);
  278.     structure_set(vs_base[0],vs_base[1],fix(vs_base[2]),vs_base[3]);
  279.     vs_base = vs_top-1;
  280. }
  281.  
  282. void
  283. siLstructurep()
  284. {
  285.     check_arg(1);
  286.     if (type_of(vs_base[0]) == t_structure)
  287.         vs_base[0] = Ct;
  288.     else
  289.         vs_base[0] = Cnil;
  290. }
  291.  
  292. siLrplaca_nthcdr()
  293. {
  294. /*
  295.     Used in DEFSETF forms generated by DEFSTRUCT.
  296.     (si:rplaca-nthcdr x i v) is equivalent to 
  297.     (progn (rplaca (nthcdr i x) v) v).
  298. */
  299.     int i;
  300.     object l;
  301.  
  302.     check_arg(3);
  303.     if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0)
  304.         FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]);
  305.     if (type_of(vs_base[0]) != t_cons)
  306.         FEerror("~S is not a cons.", 1, vs_base[0]);
  307.  
  308.     for (i = fix(vs_base[1]), l = vs_base[0];  i > 0; --i) {
  309.         l = l->c.c_cdr;
  310.         if (endp(l))
  311.             FEerror("The offset ~S is too big.", 1, vs_base[1]);
  312.     }
  313.     take_care(vs_base[2]);
  314.     l->c.c_car = vs_base[2];
  315.     vs_base = vs_base + 2;
  316. }
  317.  
  318. siLlist_nth()
  319. {
  320. /*
  321.     Used in structure access functions generated by DEFSTRUCT.
  322.     si:list-nth is similar to nth except that
  323.     (si:list-nth i x) is error if the length of the list x is less than i.
  324. */
  325.     int i;
  326.     object l;
  327.  
  328.     check_arg(2);
  329.     if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0)
  330.         FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]);
  331.     if (type_of(vs_base[1]) != t_cons)
  332.         FEerror("~S is not a cons.", 1, vs_base[1]);
  333.  
  334.     for (i = fix(vs_base[0]), l = vs_base[1];  i > 0; --i) {
  335.         l = l->c.c_cdr;
  336.         if (endp(l))
  337.             FEerror("The offset ~S is too big.", 1, vs_base[0]);
  338.     }
  339.  
  340.     vs_base[0] = l->c.c_car;
  341.     vs_pop;
  342. }
  343.  
  344.  
  345. siLmake_s_data_structure()
  346. {object x,y,raw,*base;
  347.  int i;
  348.  check_arg(5);
  349.  x=vs_base[0];
  350.  base=vs_base;
  351.  raw=vs_base[1];
  352.  y=alloc_object(t_structure);
  353.  y->str.str_def=y;
  354.  y->str.str_self = (object *)( x->v.v_self);
  355.  S_DATA(y)->name  =siLs_data;
  356.  S_DATA(y)->length=(raw->v.v_dim);
  357.  S_DATA(y)->raw   =raw;
  358.  for(i=3; i<raw->v.v_dim; i++)
  359.    y->str.str_self[i]=Cnil;
  360.  S_DATA(y)->slot_position=base[2];
  361.  S_DATA(y)->slot_descriptions=base[3];
  362.  S_DATA(y)->staticp=base[4];
  363.  S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
  364.  vs_base[0]=y;
  365.  vs_top=vs_base+1;
  366. }
  367.  
  368. void
  369. siLstructure_def()
  370. {check_arg(1);
  371.  check_type_structure(vs_base[0]);
  372.   vs_base[0]=vs_base[0]->str.str_def;
  373. }
  374.  
  375. short aet_sizes [] = {
  376. sizeof(object),  /* aet_object  t  */
  377. sizeof(char),  /* aet_ch  string-char  */
  378. sizeof(char),  /* aet_bit  bit  */
  379. sizeof(fixnum),  /* aet_fix  fixnum  */
  380. sizeof(float),  /* aet_sf  short-float  */
  381. sizeof(double),  /* aet_lf  long-float  */
  382. sizeof(char),  /* aet_char  signed char */
  383. sizeof(char),  /* aet_uchar  unsigned char */
  384. sizeof(short),  /* aet_short  signed short */
  385. sizeof(short)  /* aet_ushort  unsigned short   */
  386. };
  387.  
  388.   
  389.  
  390.  
  391.  
  392. void
  393. siLsize_of() 
  394. { object x= vs_base[0];
  395.   int i;
  396.   i= aet_sizes[get_aelttype(x)];
  397.   vs_base[0]=make_fixnum(i);
  398. }
  399.   
  400. void
  401. siLaet_type()
  402. {vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}
  403.  
  404.  
  405. /* Return N such that something of type ARG can be aligned on
  406.    an address which is a multiple of N */
  407.  
  408.  
  409. void
  410. siLalignment()
  411. {struct {double x; int y; double z;
  412.      float x1; int y1; float z1;}
  413.  joe;
  414.  joe.z=3.0;
  415.  
  416.  if (vs_base[0]==Slong_float)
  417.    {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
  418.  else
  419.    if (vs_base[0]==Sshort_float)
  420.      {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
  421.    else
  422.      {siLsize_of();}
  423. }
  424.    
  425.  
  426.  
  427. init_structure_function()
  428. {
  429.         siLs_data=make_si_ordinary("S-DATA");
  430.     make_si_function("MAKE-STRUCTURE", siLmake_structure);
  431.     make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
  432.     make_si_function("COPY-STRUCTURE", siLcopy_structure);
  433.     make_si_function("STRUCTURE-NAME", siLstructure_name);
  434.     make_si_function("STRUCTURE-REF", siLstructure_ref);
  435.     make_si_function("STRUCTURE-DEF", siLstructure_def);
  436.     make_si_function("STRUCTURE-REF1", siLstructure_ref1);
  437.     make_si_function("STRUCTURE-SET", siLstructure_set);
  438.     make_si_function("STRUCTUREP", siLstructurep);
  439.     make_si_function("SIZE-OF", siLsize_of);
  440.     make_si_function("ALIGNMENT",siLalignment);
  441.     make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
  442.     make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr);
  443.     make_si_function("LIST-NTH", siLlist_nth);
  444.     make_si_function("AET-TYPE",siLaet_type);
  445. }
  446.